home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / ti / pcscm3_3 / pkdisk2.arc / SCPSDEMO.S < prev    next >
Encoding:
Text File  |  1988-06-07  |  3.2 KB  |  135 lines
  1. ;
  2. ; This is an example of using SCOOPS. Please refer to chapter 5 in the
  3. ; Language Reference Manual for TI Scheme. 
  4. ;
  5. ; The first thing that needs to be done is to define classes for different
  6. ; types. We will define three types, points, lines and rectangles.
  7.  
  8. (load "scoops.fsl")
  9.  
  10. ;;;
  11. ;;; Point, Line and Rectangle
  12. ;;;
  13.  
  14. ;;;
  15. ;;; Class POINT
  16. ;;;
  17.  
  18. (define-class point
  19.           (instvars (x     (active 0       () move-x))
  20.             (y     (active 0       () move-y))
  21.             (color (active 'yellow () change-color)))
  22.           (options    settable-variables
  23.             inittable-variables))
  24.  
  25. (compile-class point)          ; see page 45 in the language reference manual
  26.  
  27. ;;;
  28. ;;; Class LINE
  29. ;;;
  30.  
  31. (define-class line
  32.           (instvars (len (active 50 () change-length))
  33.             (dir (active 0    () change-direction)))
  34.           (mixins point)  ; inherit x, y, and color from point class.
  35.           (options settable-variables))
  36.  
  37. (compile-class line)
  38.  
  39. ;;;
  40. ;;; Class RECTANGLE
  41. ;;;
  42.  
  43. (define-class rectangle
  44.           (instvars (height (active 60 () change-height)))
  45.           (mixins line)  ; inherit color and width (len) from line
  46.           (options settable-variables))
  47.  
  48. (compile-class rectangle)
  49.  
  50. ; In order to have an occurance of a class you will need to use the
  51. ; MAKE-INSTANCE procedure. For example:
  52. ;     (define p1 (make-instance point))
  53. ; Then to change parts of the class use the send function. For example
  54. ; to change the color of the point previously defined:
  55. ;     (send p1 change "color" 'cyan)
  56. ;
  57.  
  58. ;;;
  59. ;;; Methods for POINT
  60. ;;;
  61.  
  62. (define-method (point erase) ()
  63.            (set-pen-color! 'black)
  64.            (draw))
  65.  
  66. (define-method (point draw) ()
  67.            (draw-point x y))
  68.  
  69. ; having both a draw and redraw function here may seem to be unnecessary.
  70. ; you will see why both are needed as we continue
  71.  
  72. (define-method (point redraw) ()
  73.            (set-pen-color! color)
  74.            (draw))
  75.  
  76. (define-method (point move-x) (new-x)
  77.            (erase)
  78.            (set! x new-x)
  79.            (redraw)
  80.            new-x)
  81.  
  82. (define-method (point move-y) (new-y)
  83.            (erase)
  84.            (set! y new-y)
  85.            (redraw)
  86.            new-y)
  87.  
  88. (define-method (point change-color) (new-color)
  89.            (erase)
  90.            (set! color new-color)
  91.            (redraw)
  92.            new-color)
  93. ;;;
  94. ;;; Methods for LINE
  95. ;;;
  96.  
  97. ; inherit erase, redraw, move-x, move-y and change-color from point.
  98.  
  99. (define-method (line draw) ()
  100.            (position-pen x y)
  101.            (draw-line-to (truncate (+ x (* len (cos dir))))
  102.                  (truncate (+ y (* len (sin dir))))))
  103.  
  104. (define-method (line change-length) (new-length)
  105.            (erase)
  106.            (set! len new-length)
  107.            (redraw)
  108.            new-length)
  109.  
  110. (define-method (line change-direction) (new-dir)
  111.            (erase)
  112.            (set! dir new-dir)
  113.            (redraw)
  114.            new-dir)
  115.  
  116. ;;;
  117. ;;; Methods for RECTANGLE
  118. ;;;
  119.  
  120. ; inherit erase, redraw, move-x, move-y and change-color from point.
  121.  
  122. (define-method (rectangle draw) ()
  123.            (position-pen x y)
  124.            (draw-line-to (+ x len) y)
  125.            (draw-line-to (+ x len) (+ y height))
  126.            (draw-line-to x (+ y height))
  127.            (draw-line-to x y))
  128.  
  129. (define-method (rectangle change-height) (new-height)
  130.            (erase)
  131.            (set! height new-height)
  132.            (redraw)
  133.            new-height)
  134.  
  135.